Technotools/Technotools (Chestnut CD-ROM)(1993).ISO/lang_c/api_shar/sharea.pas

Pascal/Delphi Source File | 1989-01-25 | 5KB | 202 lines

(****************************************************************
*
*  Name:          SHAREA
*
*  Function:      share memory/data among multiple processes
*
*  Shows how to:  1. allocate and deallocate shared memory.
*                 2. read from and write to shared memory.
*                 3. mail to another process the address of shared data.
*                 4. control access to shared data via mailbox semaphore.
*
*  Written by:    Larry Rush, Quarterdeck Office Systems
*
*  Contact:       Voice:  [phone], [phone]
*                 BBS:    [phone], [phone]
*                 Fax:    [phone]
*
****************************************************************)

program ShareA;

uses DVAPI;

const

  (* minimum API version required *)
  REQUIRED = $200;

  (* PIF-related constants *)
  PIFNAME = 'SHAREB.DVP';
  PIFLEN = 416;

  (* arbitrary # times to read/write shared memory *)
  REPS = 4;

var

  (* API version number *)
  version : integer;

  (* TFDD text file *)
  tfd : text;

  (* PIF-related variables *)
  fp : file;
  dvpbuf : array [0..415] of char;
  pathbuf : string;

  (* application handle of other process *)
  apphanb : ULONG;

  (* mail-related variables *)
  error : integer;

  (* read/write loop control variable *)
  i : integer;

type

  (* type declarations related to shared data *)
  (*i* DATATYPE = integer; *i*)
  DATATYPE = string[10];
  DATAPTR = ^DATATYPE;
  (*r* DATATYPE = record *r*)
    (*r* link : DATAPTR; *r*)
    (*r* lng : integer; *r*)
    (*r* data : string[10]; *r*)
  (*r* end; *r*)

const

  (* constant value to be assigned to shared memory *)
  (*i* SHRCONST : DATATYPE = 11111; *i*)
  SHRCONST : DATATYPE = 'AAAAA     ';
  (*r* SHRCONST : DATATYPE = ( *r*)
    (*r* link : Nil; *r*)
    (*r* lng : 11111; *r*)
    (*r* data : 'AAAAA     ' *r*)
  (*r* ); *r*)

var

  (* pointer to shared data *)
  bufptr : DATAPTR;

  (* mailbox semaphore controlling access to shared memory *)
  sema : ULONG;

const

  (* global name of mailbox semaphore *)
  name : string = 'Shared Memory Semaphore';


(********************************************************************
*  program_body  -  read, display and modify contents of shared data.
********************************************************************)

procedure program_body;
begin

  (* open TFDD *)
  tfd_open (tfd,win_me);

  (* read other process' dvp file into buffer area *)
  assign (fp,PIFNAME);
  reset (fp,PIFLEN);
  blockread (fp,dvpbuf,1);
  close (fp);

  (* move current drive/path into DVP buffer *)
  getdir (0,pathbuf);
  dvpbuf[100] := pathbuf[1];
  move (pathbuf[3],dvpbuf[101],length(pathbuf)-2);

  (* start other process & get its task handle *)
  apphanb := app_start (@dvpbuf,PIFLEN);

  (* create & name mailbox semaphore *)
  sema := mal_new;
  mal_sname (sema,name);

  (* allocate shared memory & get its buffer pointer *)
  bufptr := api_getmem (sizeof (DATATYPE));

  (* copy initial data into shared memory *)
  bufptr^ := SHRCONST;

  (* mail to other process the pointer to shared data *)
  error := mal_write (mal_of (apphanb),@bufptr,sizeof (bufptr));

  (* disallow closing of window *)
  win_disallow (win_me,ALW_CLOSE);

  (* loop till handle of other process is no longer valid *)
  while (api_isobj (apphanb)) do
  begin

    (* lock semaphore *)
    mal_lock (sema);

    (* loop REPS times *)
    for i := 1 to REPS do
    begin

      (* read & display current contents & address of shared data *)
      (*i* writeln (tfd,bufptr^,' at ',seg (bufptr^),':',ofs (bufptr^)); *i*)
      writeln (tfd,bufptr^,' at ',seg (bufptr^),':',ofs (bufptr^));
      (*r* with bufptr^ do *r*)
        (*r* writeln (tfd,lng,' ',data,' at ',seg (bufptr^),':',ofs (bufptr^)); *r*)

      (* modify contents of shared data *)
      bufptr^ := SHRCONST;

    end;

    (* unlock semaphore *)
    mal_unlock (sema);

  end;

  (* allow closing of window *)
  win_allow (win_me,ALW_CLOSE);

  (* free allocated shared memory *)
  api_putmem (bufptr);

  (* free allocated object *)
  mal_free (sema);

  (* close TFDD *)
  tfd_close (tfd);

end;


(**********************************************************************
*  main  -  check for DESQview present and enable required extensions.
***********************************************************************)

begin

  (* initialize Pascal interfaces and get API version number *)
  version := api_init;

  (* if DESQview is not running or version is too low, display a message *)
  if (version < REQUIRED) then
    writeln ('This program requires DESQview version ',REQUIRED div 256,
       '.',(REQUIRED mod 256) div 16,(REQUIRED mod 256) mod 16,' or later.')

  (* tell DESQview what extensions to enable and start application *)
  else
  begin
    api_level (REQUIRED);
    program_body;
  end;

  (* disable Pascal interfaces and return from program *)
  api_exit;

end.